home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / eval.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  48KB  |  1,740 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #include "hdr.h"
  11. #include "vars.h"
  12. #include "attr.h"
  13. #include "arithp.h"
  14. #include "setp.h"
  15. #include "errmsgp.h"
  16. #include "nodesp.h"
  17. #include "machinep.h"
  18. #include "sspansp.h"
  19. #include "chapp.h"
  20. #include "miscp.h"
  21. #include "smiscp.h"
  22. #include "evalp.h"
  23.  
  24. /* Define DETAIL to break up some complicated expresssions into
  25.  * several statements to assist debugging using interactive debugger
  26.  */
  27. #define DETAIL
  28.  
  29. static Const const_val(Symbol);
  30. static Const eval_lit_map(Symbol);
  31. static Const const_fold(Node);
  32. static Const fold_unop(Node);
  33. static Const fold_op(Node);
  34. static Const fold_attr(Node);
  35. static Const fold_convert(Node);
  36. static Const eval_qual_range(Node, Symbol);
  37. static Const eval_real_type_attribute(Node);
  38. static Const check_overflow(Node, Const);
  39. static int  *fl_mantissa(int);
  40. static int *fl_emax(int);
  41. static void insert_and_prune(Node, Const);
  42. static Rational fx_max (Rational, Rational);
  43. static Const test_expr(int);
  44.  
  45. extern Const int_const(), real_const(), rat_const();
  46. extern ADA_MIN_INTEGER;
  47.  
  48. /* TBSL:provide proper link to ADA_SMALL_REAL*/
  49. #define ADA_SMALL_REAL 0.1
  50.  
  51. static Const const_val(Symbol obj)                                /*;const_val*/
  52. {
  53.     /* Return the constant value of the object if it has one;
  54.      * else return om.
  55.      * The constant value of a user-defined constant is derived from
  56.      * its SIGNATURE, when this is a constant value.
  57.      * The constant value of a literal is obtained from the literal map
  58.      * of its type.
  59.      */
  60.  
  61.     Tuple    sig;
  62.  
  63.     if (cdebug2 > 3) TO_ERRFILE("const_val");
  64.  
  65.     if (is_literal(obj)) return eval_lit_map(obj);
  66.  
  67.     sig = SIGNATURE(obj);
  68.     if( is_constant(obj) && is_scalar_type(TYPE_OF(obj))
  69.       && N_KIND((Node)sig) == as_ivalue) {
  70.         return (Const) N_VAL((Node)sig);
  71.         /* TBSL: could be static but not constant folded yet. */
  72.     }
  73.     else return const_new(CONST_OM);
  74. }
  75.  
  76. static Const eval_lit_map(Symbol obj)                    /*;eval_lit_map*/
  77. {
  78.     Symbol    typ;
  79.     Tuple    tup;
  80.     int    i;
  81.  
  82.     typ = TYPE_OF(obj);
  83.     tup = (Tuple) literal_map(typ);
  84.     for (i = 1; i <= tup_size(tup); i += 2) {
  85.         if (ORIG_NAME(obj) == (char *)0) continue;
  86.         if (streq(tup[i], ORIG_NAME(obj)))
  87.             return int_const((int)tup[i+1]);
  88.     }
  89.     return const_new(CONST_OM);
  90.     /*(return literal_map(TYPE_OF(obj))(original_name(obj));*/
  91. }
  92.  
  93. void eval_static(Node node)                                /*;eval_static*/
  94. {
  95.     /* Top level evaluation of static expressions and constant folding. The
  96.      * recursive procedure const_fold is invoked, and a top-level range 
  97.      * check on numeric results is performed.
  98.      */
  99.     /* If the node type is set to as_ivalue, the the N_VAL field will
  100.      * be a Const.
  101.      */
  102.     Const    result;
  103.  
  104.     result = const_fold(node);
  105.     if (result->const_kind != CONST_OM)
  106.         check_overflow(node, result);
  107. }
  108.  
  109. static Const const_fold(Node node)                            /*;const_fold*/
  110. {
  111.     /* This recursive procedure evaluates expressions, when static.
  112.      * If node is static, its actual value     is returned,  and the    node is
  113.      * modified to be an ivalue. Otherwise const_fold returns om, and node
  114.      * is    untouched. If the static  evaluation shows that the  expression
  115.      * would  raise an exception, a ['raise' exception] value  is produced
  116.      * and placed on the tree.
  117.      */
  118.  
  119.     Fortup ft1;
  120.     Node expn, index_list, index, discr_range;
  121.     Const    result;
  122.     Node    opn;
  123.     Node    n2, op_range;
  124.     Symbol    sym, op_type;
  125.  
  126.     /* */
  127. #define is_simple_value(t) ((t)->const_kind == CONST_INT \
  128.     || (t)->const_kind == CONST_UINT || (t)->const_kind == CONST_REAL)
  129.  
  130.     if (cdebug2 > 3) { }
  131.  
  132.     switch (N_KIND(node)) {
  133.     case(as_simple_name):
  134.         result = const_val(N_UNQ(node));
  135.         break;
  136.     case(as_ivalue):
  137.         result = (Const) N_VAL(node);
  138.         break;
  139.     case(as_int_literal):
  140.         /* TBSL: assuming int literal already converted check this Const*/
  141.         result = (Const) N_VAL(node);
  142.         break;
  143.     case(as_real_literal):
  144.         /*TBSL: assuming real literal already converted */
  145.         result = (Const) N_VAL(node);
  146.         break;
  147.     case(as_string_ivalue):
  148.         /* Will be static if required type has static low bound.*/
  149.         /*        indx := index_type(N_TYPE(node));
  150.          *        [-, lo_exp, -] := signature(indx);
  151.          * * Move this test to the expander, once format of aggregates is known.
  152.          *        if is_static_expr(lo_exp) then
  153.          *           lob := N_VAL(lo_exp);
  154.          *           av  := [v : [-, v] in comp_list];
  155.          *           result := check_null_aggregate(av, lob, indices, node);
  156.          *           result := ['array_ivalue', [v: [-, v] in comp_list], 
  157.          *                       lob, lob + #comp_list - 1];
  158.          *        else
  159.          */
  160.         result = const_new(CONST_OM);
  161.         /*        end if;    */
  162.         break;
  163.     case(as_character_literal):
  164.         result = const_new(CONST_STR);
  165.         break;
  166.     case(as_un_op):
  167.         result = fold_unop(node);
  168.         break;
  169.     case(as_in):
  170.         opn = N_AST1(node);
  171.         op_range = N_AST2(node);
  172.         result = eval_qual_range(opn, N_TYPE(op_range));
  173.         if (is_const_constraint_error(result))
  174.             result = test_expr(FALSE);
  175.         else if (!is_const_om(result))
  176.             result = test_expr(TRUE);
  177.         break;
  178.     case(as_notin):
  179.         opn = N_AST1(node);
  180.         n2 = N_AST2(node);
  181.         result = eval_qual_range(opn, N_TYPE(n2));
  182.         if (is_const_constraint_error(result))
  183.             result = test_expr(TRUE);
  184.         else if (!is_const_constraint_error(result))
  185.             result = test_expr(FALSE);
  186.         break;
  187.     case(as_op):
  188.         result = fold_op(node);
  189.         break;
  190.     case(as_call):
  191.         {
  192.             int i;
  193.             Tuple arg_list;
  194.             Const arg;
  195.  
  196.             opn = N_AST1(node);
  197.             result = const_new(CONST_OM);       /* in general not static */
  198.             arg_list = N_LIST(N_AST2(node));    /* but can fold actuals. */
  199.             for (i = 1; i <= tup_size(arg_list); i++)
  200.                 arg = const_fold((Node)arg_list[i]);
  201.             if (N_KIND(opn) == as_simple_name) {
  202.                 sym = ALIAS(N_UNQ(opn));
  203.                 if (sym != (Symbol)0 && is_literal(sym))
  204.                     /* replace call by actual value of literal */
  205.                     result = eval_lit_map(sym);
  206.             }
  207.         }
  208.         break;
  209.     case(as_parenthesis):
  210.         /* If the parenthesised expression is evaluable, return
  211.          * its value. Otherwise leave it parenthesised.
  212.          */
  213.         opn = N_AST1(node);
  214.         result = const_fold(opn);
  215.         break;
  216.     case(as_qual_range):
  217.         opn = N_AST1(node);
  218.         op_type = N_TYPE(node);
  219.         result = eval_qual_range(opn, op_type);
  220.         if (is_const_constraint_error(result)) {
  221.             create_raise(node, symbol_constraint_error);
  222.             result = const_new(CONST_OM);
  223.         }
  224.         break;
  225.     case(as_qual_index):
  226.         eval_static(N_AST1(node));
  227.         result = const_new(CONST_OM);
  228.         break;
  229.     case(as_attribute):
  230.     case(as_range_attribute):
  231.         /* use separate procedure for C */
  232.         result = fold_attr(node);
  233.         break;
  234.     case(as_qualify):
  235.         if (fold_context)
  236.             result = const_fold(N_AST2(node));
  237.         else
  238.             /* in the context of a conformance check, keep qualification.*/
  239.             result = const_new(CONST_OM);
  240.         break;
  241.         /* Type conversion:
  242.          * /TBSL/ These conversions are not properly checked!
  243.          */
  244.     case(as_convert):
  245.         /* use separate procedure for C */
  246.         result = fold_convert(node);
  247.         break;
  248.     case(as_array_aggregate):
  249.         /* This is treated in the expander.*/
  250.         result = const_new(CONST_OM);
  251.         break;
  252.     case(as_record_aggregate):
  253.         result = const_new(CONST_OM);
  254.         break;
  255.     case(as_selector): /*TBSL Case for discriminants needed */
  256.         expn = N_AST1(node);
  257.         eval_static(expn);
  258.         return const_new(CONST_OM);
  259.     case(as_slice):
  260.         expn = N_AST1(node);
  261.         discr_range = N_AST2(node);
  262.         eval_static(expn);
  263.         eval_static(discr_range);
  264.         return const_new(CONST_OM);
  265.     case(as_row):    /* Not folded for now.*/
  266.         /* p1 := check_const_val(op1);
  267.          * if is_value(op1) then
  268.          *    result := ['array_ivalue', [op1(2)], 1, 1];
  269.          * else
  270.          */
  271.         return const_new(CONST_OM);
  272.     case(as_index):
  273.         expn = N_AST1(node);
  274.         index_list = N_AST2(node);
  275.         eval_static(expn);
  276.  
  277.         FORTUP(index = (Node), N_LIST(index_list), ft1)
  278.             eval_static(index);
  279.         ENDFORTUP(ft1);
  280.         return const_new(CONST_OM);
  281.     default:
  282.         result = const_new(CONST_OM);
  283.     }
  284.     if (result->const_kind != CONST_OM)
  285.         insert_and_prune(node, result);
  286.  
  287.     return result;
  288. }
  289.  
  290. static Const fold_unop(Node node)                                /*;fold_unop*/
  291. {
  292.     Node    opn, oplist;
  293.     Const    result, op1;
  294.     int    op1_kind;
  295.     Symbol    sym;
  296.  
  297.     opn = N_AST1(node);
  298.     oplist = N_AST2(node);
  299.     op1 = const_fold((Node) (N_LIST(oplist))[1]);
  300.  
  301.     if (is_const_om(op1)) return op1;
  302.  
  303.     op1_kind = op1->const_kind;
  304.  
  305.     sym = N_UNQ(opn);
  306.     if (sym == symbol_addui) {
  307.         /*  the "+" can be ignored if it is used as a unary op */
  308.         result = op1;
  309.     }
  310.     else if (sym == symbol_addufl) {
  311.         result = op1;
  312.     }
  313.     else if (sym == symbol_addufx) {
  314.         result = op1;
  315.     }
  316.     else if (sym == symbol_subui ||
  317.         sym == symbol_subufl || sym == symbol_subufx) {
  318.         if (is_simple_value(op1)) {
  319.             if (sym == symbol_subui) {
  320.                 if (is_const_int(op1)) {
  321.                     if (INTV(op1) == ADA_MIN_INTEGER) {
  322.                         create_raise(node, symbol_constraint_error);
  323.                         result = const_new(CONST_OM);
  324.                     }
  325.                     else {
  326.                        result = int_const(-INTV(op1));
  327.                     }
  328.                 }
  329.                 else if (is_const_uint(op1))
  330.                     result = uint_const(int_umin(UINTV(op1)));
  331.                 else chaos("eval:subui bad type");
  332.             }
  333.             else if (sym == symbol_subufl) {
  334.                 const_check(op1, CONST_REAL);
  335.                 result = real_const(-REALV(op1));
  336.             }
  337.         }
  338.         else {
  339.             const_check(op1, CONST_RAT);
  340.             result= rat_const(rat_umin(RATV(op1)));
  341.         }
  342.     }
  343.     else if ( sym == symbol_not) {
  344.         if (is_simple_value (op1)) {
  345.             if (op1_kind == CONST_INT)
  346.                 result = int_const(1-INTV(op1)); /*bnot in setl */
  347.             else chaos("fold_unop: bad kind");
  348.         }
  349.         else {        /*TBSL*/
  350.             result = const_new(CONST_OM);
  351.         }
  352.     }
  353.     else if ( sym == symbol_absi ||
  354.         sym == symbol_absfl || sym == symbol_absfx) {
  355.  
  356.         if (is_simple_value(op1)) {
  357.             if (sym == symbol_absi) {
  358.                 if (op1_kind == CONST_INT) result = int_const(abs(INTV(op1)));
  359.                 else if (op1_kind == CONST_UINT)chaos("fold_unit absi in uint");
  360.                 else chaos("fold_unop: bad kind");
  361.             }
  362.             else if (sym == symbol_absfl) {
  363.                 result = real_const(fabs(REALV(op1)));
  364.             }
  365.         }
  366.         else {
  367.             result= rat_const(rat_abs(RATV(op1)));
  368.         }
  369.     }
  370.     return result;
  371. }
  372.  
  373. static Const fold_op(Node node)                                    /*;fold_op*/
  374. {
  375.     Node    opn, arg1, arg2, oplist;
  376.     Const    result, op1, op2, tryc;
  377.     Symbol    sym, op_name;
  378.     int    *uint;
  379.     int    rm;
  380.     Tuple    tup;
  381.     int    res, overflow;
  382.  
  383.     opn = N_AST1(node);
  384.     oplist = N_AST2(node);
  385.     tup = N_LIST(oplist);
  386.     arg1 = (Node) tup[1];
  387.     arg2 = (Node) tup[2];
  388.     op1 = const_fold(arg1);
  389.     op2 = const_fold(arg2);
  390.     op_name = N_UNQ(opn);
  391.  
  392.     /* If either operand raises and exception, so does the operation */
  393.     if (N_KIND(arg1) == as_raise) {
  394.         copy_attributes(arg1,  node);
  395.         return const_new(CONST_OM);
  396.     }
  397.     if (N_KIND(arg2) == as_raise 
  398.       && op_name != symbol_andthen && op_name != symbol_orelse) {
  399.         copy_attributes(arg2,  node);
  400.         return const_new(CONST_OM);
  401.     }
  402.  
  403.     if (is_const_om(op1) || (is_const_om(op2)
  404.       && (op_name != symbol_in || op_name != symbol_notin))) {
  405.         return const_new(CONST_OM);
  406.     }
  407.  
  408.     sym = op_name;
  409.  
  410.     if ( sym == symbol_addi || sym == symbol_addfl) {
  411.         if (sym == symbol_addi) {
  412.             res = word_add(INTV(op1), INTV(op2), &overflow);
  413.             if (overflow) {
  414.                 create_raise(node, symbol_constraint_error);
  415.                 result = const_new(CONST_OM);
  416.             }
  417.             else result = int_const(res);
  418.         }
  419.         else
  420.             result = real_const(REALV(op1) + REALV(op2));
  421.     }
  422.     else if ( sym == symbol_addfx) {
  423.         const_check(op1, CONST_RAT);
  424.         const_check(op2, CONST_RAT);
  425.         result= rat_const(rat_add(RATV(op1), RATV(op2)));
  426.     }
  427.     else if ( sym == symbol_subi) {
  428.         if (is_const_int(op1)) {
  429.             if (is_const_int(op2)) {
  430.                 res = word_sub(INTV(op1), INTV(op2), &overflow);
  431.                 if (overflow) {
  432.                     create_raise(node, symbol_constraint_error);
  433.                     result = const_new(CONST_OM);
  434.                 }
  435.                 else result = int_const(res);
  436.             }
  437.             else {
  438.                 chaos("fold_op: subi operand types");
  439.             }
  440.         }
  441.     }
  442.     else if (sym == symbol_subfl) {
  443.         result = real_const(REALV(op1) - REALV(op2));
  444.     }
  445.     else if ( sym == symbol_subfx) {
  446.         const_check(op1, CONST_RAT);
  447.         const_check(op2, CONST_RAT);
  448.         result= rat_const(rat_sub(RATV(op1), RATV(op2)));
  449.     }
  450.     else if ( sym == symbol_muli) {
  451. #ifdef TBSL
  452.         -- need to check for overflow and convert result back to int if not
  453.             -- note that low-level setl is missing calls to check_overflow that
  454.             -- are present in high-level and should be in low-level as well
  455.             result = int_mul(int_fri(op1), int_fri(op2));
  456. #endif
  457.         /* until overflow check in */
  458.         const_check(op1, CONST_INT);
  459.         const_check(op2, CONST_INT);
  460.         res = word_mul(INTV(op1), INTV(op2), &overflow);
  461.         if (overflow) {
  462.             create_raise(node, symbol_constraint_error);
  463.             result = const_new(CONST_OM);
  464.         }
  465.         else result = int_const(res);
  466.     }
  467.     else if ( sym == symbol_mulfl) {
  468.         const_check(op1, CONST_REAL);
  469.         const_check(op2, CONST_REAL);
  470.         if ((fabs(REALV(op1)) < ADA_SMALL_REAL)
  471.           || (fabs(REALV(op2)) < ADA_SMALL_REAL)) {
  472.             result = real_const(0.0);
  473.         }
  474.         else if (log(fabs(REALV(op1))) + 
  475.             log(fabs(REALV(op2))) > ADA_MAX_REAL) {
  476.             create_raise(node, symbol_constraint_error);
  477.             return const_new(CONST_OM);
  478.         }
  479.         else
  480.             result = real_const(REALV(op1) * REALV(op2));
  481.     }
  482.     else if ( sym == symbol_mulfx) {
  483.         const_check(op1, CONST_RAT);
  484.         const_check(op2, CONST_RAT);
  485.         result = rat_const(rat_mul(RATV(op1), RATV(op2)));
  486.     }
  487.     else if (sym == symbol_mulfxi || sym == symbol_mulfli) {
  488.         const_check(op1, CONST_RAT);
  489.         const_check(op2, CONST_RAT);
  490.         result = rat_const(rat_fri(int_mul(num(RATV(op1)), UINTV(op2)),
  491.           den(RATV(op1))));
  492.     }
  493.     else if (sym == symbol_mulifx) {
  494.         const_check(op1, CONST_UINT);
  495.         const_check(op2, CONST_RAT);
  496.         result = rat_const(rat_fri(int_mul(UINTV(op1), num(RATV(op2))),
  497.           den(RATV(op2))));
  498.     }
  499.     else if (sym == symbol_divi) {
  500.         if (INTV(op2)== 0) {
  501.             create_raise(node, symbol_constraint_error);
  502.             return const_new(CONST_OM);
  503.         }
  504.         result = int_const(INTV(op1) / INTV(op2));
  505.     }
  506.     else if (sym == symbol_divfl) {
  507.         const_check(op2, CONST_REAL);
  508.         if (fabs(REALV(op2)) < ADA_SMALL_REAL) {
  509.             create_raise(node, symbol_constraint_error);
  510.             return const_new(CONST_OM);
  511.         }
  512.         else if (fabs(REALV(op1)) < ADA_SMALL_REAL) {
  513.             const_check(op1, CONST_REAL);
  514.             result = real_const(0.0);
  515.         }
  516.         else if (log(fabs(REALV(op1))) -
  517.           log(fabs(REALV(op2))) >log(ADA_MAX_REAL)) {
  518.             create_raise(node, symbol_constraint_error);
  519.             return const_new(CONST_OM);
  520.         }
  521.         else {
  522.             result = real_const(REALV(op1)
  523.                 / REALV(op2));
  524.         }
  525.     }
  526.     else if (sym == symbol_divfx) {
  527.         /* TBSL: note that rnum(rat2) is in long integer format */
  528.         if (int_eqz(num(RATV(op2)))) {
  529.             create_raise(node, symbol_constraint_error);
  530.             return const_new(CONST_OM);
  531.         }
  532.         result = rat_const(rat_div(RATV(op1), RATV(op2)));
  533.     }
  534.     else if (sym == symbol_divfxi ||  sym == symbol_divfli) {
  535.         const_check(op1, CONST_RAT);
  536.         if (is_const_int(op2)) {
  537.             if (!INTV(op2)) {
  538.                 create_raise(node, symbol_constraint_error);
  539.                 return const_new(CONST_OM); }
  540.             result = rat_const(rat_fri(num(RATV(op1)), int_mul(den(RATV(op1)),
  541.               int_fri(INTV(op2))))); }
  542. /* Shouldn't be a rational
  543.         else if (is_const_rat(op2)) {
  544.             if (int_eqz(num(RATV(op2)))) {
  545.                 create_raise(node, symbol_constraint_error);
  546.                 return const_new(CONST_OM); }
  547.             result = rat_const(rat_div(RATV(op1), RATV(op2))); }
  548. */
  549.         else {
  550.             const_check(op2, CONST_UINT);
  551.             if (int_eqz(UINTV(op2))) {
  552.                 create_raise(node, symbol_constraint_error);
  553.                 return const_new(CONST_OM); }
  554.             result = rat_const(rat_fri(num(RATV(op1)), int_mul(den(RATV(op1)),
  555.               UINTV(op2))));
  556.         }
  557.     }
  558.     else if (sym == symbol_remi) {
  559.         if (INTV(op2) == 0) {
  560.             create_raise(node, symbol_constraint_error);
  561.             return const_new(CONST_OM);
  562.         }
  563.         result = int_const(INTV(op1) - (INTV(op1) / INTV(op2)) * INTV(op2));
  564.     }
  565.     else if (sym == symbol_modi) {
  566.         if (INTV(op2) == 0) {
  567.             create_raise(node, symbol_constraint_error);
  568.             return const_new(CONST_OM);
  569.         }
  570.         rm = INTV(op1) % INTV(op2);
  571.         if ((rm == 0) || (INTV(op2) > 0))
  572.             result = int_const(rm);
  573.         else
  574.             result = int_const(rm + INTV(op2));
  575.     }
  576.     else if (sym == symbol_expi) {
  577.         if (INTV(op2) < 0) {
  578.             create_raise(node, symbol_constraint_error);
  579.             return const_new(CONST_OM);
  580.         }
  581.         else {
  582.             if (is_const_int(op1))
  583.                 uint = int_fri(INTV(op1));
  584.             else
  585.                 chaos("expi: bad kind");
  586.             const_check(op2, CONST_INT);
  587.             result = int_const(int_toi(int_exp(uint, int_fri(INTV(op2)))));
  588.         }
  589.     }
  590.     else if (sym == symbol_expfl) {
  591.         const_check(op1, CONST_REAL);
  592.         const_check(op2, CONST_INT);
  593.         if ((fabs(REALV(op1)) < ADA_SMALL_REAL)
  594.           || ((abs(INTV(op2)) * log (fabs( REALV(op1)))) > log(ADA_MAX_REAL))) {
  595.             create_raise(node, symbol_constraint_error);
  596.             return const_new(CONST_OM);
  597.         }
  598.         return const_new(CONST_OM);
  599. #ifdef TBSL
  600.         -- need to find C form for **
  601.             pow(x, y) is x**y with x an y both double.
  602.             result = op1 ** op2;
  603. #endif
  604.     }
  605.     else if ((sym == symbol_cat) || (sym == symbol_cat_ca)
  606.       || (sym == symbol_cat_ac) || (sym == symbol_cat_cc)) {
  607.         /*  /TBSL/ Bounds may not be correct!*/
  608.         /*  [-, agg1, lb1, ub1] := op1;
  609.          *  [-, agg2, lb2, ub2] := op2;
  610.          *  agg := agg1 + agg2;
  611.          *  lb := lb1 min lb2;
  612.          */
  613.         result = const_new(CONST_OM);
  614.     }
  615.     else if (sym == symbol_and || sym == symbol_or || sym == symbol_xor) {
  616.         if (is_simple_value(op1)) {
  617.             if (N_UNQ(opn) == symbol_and) {
  618.                 if (is_const_int(op1))
  619.                     result = int_const(INTV(op1)&&INTV(op2));
  620.                 else
  621.                     chaos("fold_unop: bad kind");
  622.             }
  623.             else if (N_UNQ(opn) == symbol_or) {
  624.                 if (is_const_int(op1))
  625.                     result = int_const(INTV(op1)||INTV(op2));
  626.                 else
  627.                     chaos("fold_unop: or bad kind");
  628.             }
  629.             else if (N_UNQ(opn) == symbol_xor) {
  630.                 result = test_expr((INTV(op1))!= (INTV(op2)));
  631.             }
  632.             else {
  633.                 chaos("ERROR IN ES99");
  634.             }
  635.         }
  636.     }
  637.     else if (sym == symbol_andthen || sym == symbol_orelse) {
  638.         /* not static */
  639.         result = const_new(CONST_OM);
  640.     }
  641.     else if (sym == symbol_eq) {
  642. #ifdef TBSN
  643.         if (is_universal_real(op1) && is_universal_real(op2))
  644.             result = test_expr(rat_eql(op1, op2));
  645.         else
  646.             result = test_expr(op1 == op2);
  647. #endif
  648.         if (const_same_kind(op1, op2))
  649.             return test_expr(const_eq(op1, op2));
  650.         else return int_const(FALSE);
  651.     }
  652.     else if (sym == symbol_ne) {
  653. #ifdef TBSN
  654.         if (is_universal_real(op1) && is_universal_real(op2)) {
  655.             result = test_expr(rat_neq(op1, op2));
  656.         }
  657.         else {
  658.             /*TBSL: do we need two cases here */
  659.             if (is_const_int(op1))
  660.                 result = int_const(INTV(op1) != INTV(op2));
  661.             else if (is_const_real(op1))
  662.                 result = test_expr((REALV(op1) != REALV(op2)));
  663.             else
  664.                 chaos("error in ne case in const_fold");
  665.         }
  666. #endif
  667.         if (const_same_kind(op1, op2))
  668.             return test_expr(const_ne(op1, op2));
  669.         else return int_const(FALSE);
  670.     }
  671.     else if (sym == symbol_lt) {
  672.         if (is_simple_value(op1)) {
  673. #ifdef TBSN
  674.             if (is_const_int(op1)) {
  675.                 result = int_const(INTV(op1) < INTV(op2));
  676.             }
  677.             else {
  678.                 if (is_const_real(op1)) {
  679.                     result = real_const(REALV(op1)
  680.                         < REALV(op2));
  681.                 }
  682.                 else {
  683.                     chaos("fold_unop: lt bad kind ");
  684.                 }
  685.             }
  686. #endif
  687.             if (const_same_kind(op1, op2))
  688.                 return test_expr(const_lt(op1, op2));
  689.             else return int_const(FALSE);
  690.         }
  691.         /*TBSL     need array types */
  692.         else if (is_const_rat (op1) && is_const_rat (op2)) {
  693.             result = test_expr(rat_lss (RATV (op1), RATV (op2))); 
  694.         }
  695.         else {
  696.             result = const_new(CONST_OM); 
  697.         }
  698.     }
  699.     else if (sym == symbol_le) {
  700.         if (is_simple_value(op1)) {
  701. #ifdef TBSN
  702.             if (is_const_int(op1)) {
  703.                 result = int_const(INTV(op1) <= INTV(op2));
  704.             }
  705.             else if (is_const_real(op1)) {
  706.                 result = real_const(REALV(op1) <= REALV(op2));
  707.             }
  708.             else {
  709.                 chaos("fold_op: le bad kind");
  710.             }
  711. #endif
  712.             if (const_same_kind(op1, op2))
  713.                 return test_expr(const_le(op1, op2));
  714.             else return int_const(FALSE);
  715.         }
  716.         else {    /*TBSL need array types */
  717.             if (is_const_rat (op1) && is_const_rat (op2))
  718.                 result = test_expr(rat_leq (RATV (op1), RATV (op2))); 
  719.             else
  720.                 result = const_new(CONST_OM); 
  721.         }
  722.     }
  723.     else if (sym == symbol_gt) {
  724.         if (is_simple_value(op1)) {
  725. #ifdef TBSN
  726.             if (is_const_int(op1)) {
  727.                 result = int_const(INTV(op1) > INTV(op2));
  728.             }
  729.             else if (is_const_real(op1)) {
  730.                 result = real_const(REALV(op1)
  731.                     > REALV(op2));
  732.             }
  733.             else {
  734.                 chaos("fold_op: gt bad kind");
  735.             }
  736. #endif
  737.             if (const_same_kind(op1, op2))
  738.                 return test_expr(const_gt(op1, op2));
  739.             else return int_const(FALSE);
  740.         }
  741.         else {    /*TBSL need array types */
  742.             if (is_const_rat (op1) && is_const_rat (op2))
  743.                 result = test_expr(rat_gtr (RATV (op1), RATV (op2))); 
  744.             result = const_new(CONST_OM);
  745.         }
  746.     }
  747.     else if (sym == symbol_ge) {
  748.         if (is_simple_value(op1)) {
  749. #ifdef TBSN
  750.             if (is_const_int(op1))
  751.                 result = int_const(INTV(op1) >= INTV(op2));
  752.             else if (is_const_real(op1))
  753.                 result = real_const(REALV(op1) >= REALV(op2));
  754.             else
  755.                 chaos("fold op ge bad kind");
  756. #endif
  757.             if (const_same_kind(op1, op2))
  758.                 return test_expr(const_ge(op1, op2));
  759.             else
  760.                 return int_const(FALSE);
  761.         }
  762.         else {    /*TBSL need array types */
  763.             if (is_const_rat (op1) && is_const_rat (op2))
  764.                 result = test_expr(rat_geq (RATV (op1), RATV (op2))); 
  765.             result = const_new(CONST_OM);
  766.         }
  767.     }
  768.     else if (sym == symbol_in || sym == symbol_notin) {
  769.         specialize(arg1, N_TYPE(arg2));     /* ?? */
  770.         /* check whether this is correct, SETL is TYPE_OF, which is WRONG!!*/
  771.         if (N_KIND(arg2) != as_simple_name) {
  772.             result = const_new(CONST_OM); /* Could do better. */
  773.         }
  774.         else {
  775.             tryc = eval_qual_range(opn, N_UNQ(arg2));
  776.             if (is_const_constraint_error(tryc))
  777.                 result = test_expr(op_name == symbol_notin);
  778.             else if (!is_const_om(tryc))
  779.                 result= test_expr(op_name == symbol_in);
  780.         }
  781.  
  782.     }
  783.     else {
  784.         printf("bad operator symbol: %s\n", nature_str(NATURE(sym)));
  785.         chaos("fold_op: bad operator");
  786.     }
  787.     return result;
  788. }
  789.  
  790. static Const fold_attr(Node node)        /*;fold_attr*/
  791. {
  792.     Node    attr_node, typ_node, arg_node, f_node, l_node, l_n, h_n;
  793.     Symbol    typ1;
  794.     int        attrkind, is_t_n, rv, i, len, max;
  795.     Const    first, last, op1, result, lo, hi;
  796.     Tuple    tsig, sig, l;
  797.     Span    save_span;
  798.  
  799.     attr_node = N_AST1(node);
  800.     typ_node = N_AST2(node);
  801.     arg_node = N_AST3(node);
  802.  
  803.     /* Try to fold the prefix of the attribute*/
  804.     eval_static(typ_node);
  805.     /*attr = N_VAL(attr_node);  -- should be dead  3-13-86 ds */
  806.     attrkind = (int) attribute_kind(node);
  807.     if (N_KIND(typ_node) != as_simple_name) {
  808.         /*Not for attribute COUNT. beware!*/
  809.         typ1 = N_TYPE(typ_node);
  810.     }
  811.     else {
  812.         typ1 = N_UNQ(typ_node);
  813.     }
  814.     is_t_n = is_type_node(typ_node);
  815.     /* For array attributes, we establish whether it is being
  816.      * applied to an object or  to a type. The two operations
  817.      *  are distinguished in the interpreter by prefix O_ or T_
  818.      */
  819.     if ((attrkind == ATTR_T_FIRST || attrkind == ATTR_T_LAST
  820.       || attrkind == ATTR_T_RANGE || attrkind == ATTR_T_LENGTH )
  821.       && can_constrain(typ1) ) {
  822.  
  823.             errmsg( "attribute cannot be applied to unconstrained array type",
  824.               "3.6.2", attr_node);
  825.     }
  826.     else if (attrkind == ATTR_T_SIZE || attrkind == ATTR_O_SIZE) {
  827.         node = size_attribute(node);
  828.         if (N_KIND(node) == as_ivalue) {
  829.             return (Const) N_VAL(node);
  830.         }
  831.         else {
  832.             return const_new(CONST_OM);
  833.         }
  834.     }
  835.     else if (attrkind == ATTR_BASE) {
  836.         save_span = get_left_span(node);
  837.         N_KIND(node) = as_simple_name;
  838.         /* clear attribute code so won't be taken as string*/
  839.         N_VAL(node) = (char *)0;
  840.         N_UNQ(node)     = base_type(typ1);
  841.         set_span(node, save_span);
  842.         return const_new(CONST_OM);
  843.     }
  844.  
  845.     if (!is_t_n)return const_new(CONST_OM);
  846.     /* This was needed in the high level, to prevent extra
  847.      * folding in non-static cases. It may be superfluous here
  848.      */
  849.     /* Attributes that are functions take the base type */
  850.     if (attrkind == ATTR_BASE || attrkind == ATTR_POS || attrkind == ATTR_PRED
  851.       ||attrkind == ATTR_SUCC || attrkind == ATTR_VAL
  852.       || attrkind == ATTR_VALUE) {
  853.         N_UNQ(typ_node) = base_type(typ1);
  854.     }
  855.     if (arg_node != OPT_NODE) {
  856.         op1 = const_fold(arg_node);
  857.         if (is_const_om(op1))return const_new(CONST_OM);
  858.     }
  859.     /* They are evaluable statically only if the subtype typ1
  860.      * itself is static.
  861.      */
  862.     if (is_type(typ1) && is_static_subtype(typ1)
  863.       || is_task_type(TYPE_OF(typ1))
  864.       || attrkind == ATTR_T_CONSTRAINED || attrkind == ATTR_O_CONSTRAINED) {
  865.         ;    /* try to evaluate */
  866.     }
  867.     else {
  868.         return const_new(CONST_OM); /* not static (RM 4.9 (8)*/
  869.     }
  870.     if (is_generic_type(typ1))    return const_new(CONST_OM);
  871.  
  872.     if (is_static_subtype(typ1)) {
  873.         tsig = SIGNATURE(typ1);
  874.         f_node = (Node) tsig[2];
  875.         l_node = (Node) tsig[3];
  876.         first = const_fold(f_node);
  877.         last = const_fold(l_node);
  878.     }
  879.  
  880.     /* Attributes of SCALAR types or ARRAY types: */
  881.  
  882.     if (attrkind == ATTR_O_FIRST || attrkind == ATTR_T_FIRST)
  883.         result = first;
  884.     else if (attrkind == ATTR_O_LAST || attrkind == ATTR_T_LAST)
  885.         result = last;
  886.     else if ( attrkind == ATTR_O_LENGTH || attrkind == ATTR_T_LENGTH
  887.       || attrkind == ATTR_O_RANGE || attrkind == ATTR_T_RANGE)
  888.         result = const_new(CONST_OM);
  889.     /* Attributes of DISCRETE types: */
  890.     else if (attrkind == ATTR_IMAGE) {
  891.         Symbol btyp1;
  892.         char *image;
  893.         Tuple tup;
  894.         int tsize;
  895.  
  896.         btyp1 = root_type(typ1);
  897.  
  898.         image = emalloct(10, "fold-attr");
  899.         if (btyp1 == symbol_integer) {
  900.             const_check(op1, CONST_INT);
  901.             if (INTV(op1) >= 0) sprintf(image, " %d", INTV(op1));
  902.             else sprintf(image, "%d", INTV(op1));
  903.         }
  904.         else {
  905.             /* image := 
  906.              *   if exists [nam, v] in literal_map(btyp1) | op1 = v
  907.              *       then nam else '' end;
  908.              */
  909.             image = "";
  910.             tup = (Tuple) literal_map(btyp1);
  911.             tsize = tup_size(tup);
  912.             for (i = 1; i <= tsize; i += 2) {
  913.                 const_check(op1, CONST_INT);
  914.                 if ((int)tup[i+1] == INTV(op1)) {
  915.                     image = strjoin(tup[i], "");
  916.                     break;
  917.                 }
  918.             }
  919.         }
  920.         N_KIND(node) = as_string_ivalue;
  921.         /* N_VAL(node)     = [abs c : c in image]; */
  922.         tsize = strlen(image);
  923.         tup = tup_new(tsize);
  924.         for (i = 1; i <= tsize; i++)
  925.             tup[i] = (char *) image[i-1];
  926.  
  927.         if (N_AST1_DEFINED(N_KIND(node))) N_AST1(node) = (Node) 0;
  928.         if (N_AST2_DEFINED(N_KIND(node))) N_AST2(node) = (Node) 0;
  929.         if (N_AST3_DEFINED(N_KIND(node))) N_AST3(node) = (Node) 0;
  930.         if (N_AST4_DEFINED(N_KIND(node))) N_AST4(node) = (Node) 0;
  931.         N_VAL(node) = (char *) tup;
  932.         result = const_new(CONST_OM);
  933.     }
  934.     else if (attrkind == ATTR_VALUE) {
  935.         chaos("value attrobute (eval.c)");
  936.     }
  937.     else if (attrkind == ATTR_POS) {
  938.         const_check(op1, CONST_INT);
  939.         result = uint_const(int_fri(INTV(op1)));    /*$ES10*/
  940.         /* result = int_const(int_fri(op1)); */          /*$ES10*/
  941.     }
  942.     else if (attrkind == ATTR_VAL || attrkind == ATTR_PRED
  943.       || attrkind == ATTR_SUCC) {
  944.         const_check(op1, CONST_INT);
  945.         rv = INTV(op1);
  946.         sig = SIGNATURE(base_type(typ1));
  947.         if (sig != (Tuple)0) {
  948.             l_n = (Node) sig[2];
  949.             h_n = (Node) sig[3];
  950.         }
  951.         else {
  952.             l_n = (Node) 0;
  953.             h_n = (Node) 0;
  954.         }
  955.         lo = const_fold(l_n);
  956.         hi = const_fold(h_n);
  957.         if (is_const_om(lo) || is_const_om(hi)) {
  958.             return const_new(CONST_OM);
  959.         }
  960.         if (attrkind == ATTR_PRED) {
  961.             const_check(lo, CONST_INT);
  962.             if (rv > INTV(lo)) rv -= 1;
  963.             else {
  964.                 create_raise(node, symbol_constraint_error);
  965.                 return const_new(CONST_OM);
  966.             }
  967.         }
  968.         else if (attrkind == ATTR_SUCC) {
  969.             const_check(hi, CONST_INT);
  970.             if (rv < INTV(hi)) rv += 1;
  971.             else {
  972.                 create_raise(node, symbol_constraint_error);
  973.                 return const_new(CONST_OM);
  974.             }
  975.         }
  976.         else if (attrkind == ATTR_VAL) {
  977.             const_check(lo, CONST_INT);
  978.             const_check(hi, CONST_INT);
  979.             if (rv < INTV(lo) || rv > INTV(hi)) {
  980.                 create_raise(node, symbol_constraint_error);
  981.                 return const_new(CONST_OM);
  982.             }
  983.         }
  984.         result = int_const(rv);
  985.     }
  986.     else if (attrkind == ATTR_WIDTH) {
  987.         int first_val, last_val, max_val;
  988.  
  989.         if (root_type(typ1) == symbol_integer) {
  990.             if (is_const_om(first) || is_const_om(last))
  991.                 chaos("eval WIDTH: unexpected const_kind");
  992.             const_check(first, CONST_INT);
  993.             const_check(last, CONST_INT);
  994.             /* In the case of a null range the Width is defined as 0.
  995.              * Otherwise it is defined as the maximum IMAGE length for
  996.              * all values of the subtype.
  997.              */
  998.             if (INTV(first) > INTV(last))
  999.                 result = uint_const(int_fri(0));
  1000.             else {
  1001.                 char *val_str = emalloct(10, "fold-attr-1");
  1002.                 first_val = abs(INTV(first));
  1003.                 last_val  = abs(INTV(last));
  1004.                 max_val = (first_val > last_val ? first_val : last_val);
  1005.                 sprintf(val_str, " %d", max_val);
  1006.                 result = uint_const(int_fri(strlen(val_str)));
  1007.                 efreet(val_str, "eval-fold-rat");
  1008.             }
  1009.         }
  1010.         else {
  1011.             /*   Must find longest name in enumeration subtype.  */
  1012.             int v;
  1013.             l = (Tuple) literal_map(root_type(typ1));
  1014.             max = 0;
  1015.             first_val = abs(INTV(first));    /* bounds of subtype */
  1016.             last_val  = abs(INTV(last));
  1017.             for (i = 1; i <= tup_size(l); i += 2) {
  1018.                 len = strlen(l[i]);
  1019.                 v = (int)l[i+1];
  1020.                 if (len > max && v >= first_val && v <= last_val)
  1021.                     max = len;
  1022.             }
  1023.             result = uint_const(int_fri(max));
  1024.         }
  1025.     }
  1026.  
  1027.     /* Miscellaneous attributes. */
  1028.  
  1029.     /* The following  attributes are  of type universal integer.
  1030.      * The current system ignores them, and passes them to the expander. 
  1031.      */
  1032.  
  1033.     else if (attrkind == ATTR_POSITION || attrkind == ATTR_FIRST_BIT
  1034.       || attrkind == ATTR_LAST_BIT || attrkind == ATTR_STORAGE_SIZE) {
  1035.         result = const_new(CONST_OM);
  1036.     }
  1037.     else if (attrkind == ATTR_O_CONSTRAINED || attrkind == ATTR_T_CONSTRAINED) {
  1038.         /* Attribute is true on constants and on -in- parameters */
  1039.         if ((typ1 != (Symbol) 0) &&
  1040.             NATURE(typ1) == na_constant || NATURE(typ1) == na_in) {
  1041.             result = int_const(1);
  1042.         }
  1043.         else if (!is_generic_type(typ1)) {
  1044.             /* it is false for private  types with discriminants.  */
  1045.             result = int_const( !(is_record(typ1) && has_discriminants(typ1)
  1046.               && NATURE(typ1) != na_subtype));
  1047.         }
  1048.         else {        /* run-time check */
  1049.             result = const_new(CONST_OM);
  1050.         }
  1051.     }
  1052.     else if (attrkind == ATTR_ADDRESS || attrkind == ATTR_TERMINATED 
  1053.       || attrkind == ATTR_CALLABLE) {
  1054.         result = const_new(CONST_OM);
  1055.     }
  1056.     else {
  1057.         /* Attributes of FIXED and FLOATing point types:*/
  1058.         result = eval_real_type_attribute(node);
  1059.     }
  1060.     return result;
  1061. }
  1062.  
  1063. static Const fold_convert(Node node)                        /*;fold_convert*/
  1064. {
  1065.     Node    typ2_node, opd_node;
  1066.     Symbol    typ1, typ2; /* type2 is target type */
  1067.     Const    opd, result;
  1068.  
  1069.     typ2_node = N_AST1(node);
  1070.     opd_node = N_AST2(node);
  1071.     typ1 = root_type(N_TYPE(opd_node));
  1072.     typ2 = root_type(N_UNQ(typ2_node));
  1073.     opd = const_fold(opd_node);
  1074.     if (is_const_om(opd)) {
  1075.         return const_new(CONST_OM);
  1076.     }
  1077.     if (typ1 == symbol_integer) {
  1078.         if (typ2 == symbol_integer) {
  1079.             result = opd;
  1080.         }
  1081.         else if (typ2 == symbol_float) {
  1082.             const_check(opd, CONST_INT);
  1083.             result = real_const((float)INTV(opd));
  1084.         }
  1085.         else if (typ2 == symbol_universal_integer)    {
  1086.             const_check(opd, CONST_INT);
  1087.             result    = uint_const(int_fri(INTV(opd)));
  1088.         }
  1089.         else if (typ2 == symbol_universal_real
  1090.           || typ2 == symbol_universal_fixed || typ2 == symbol_dfixed) {
  1091.             if (is_const_int(opd)) {
  1092.                 result = rat_const(rat_fri(int_fri(INTV(opd)), int_fri(1)));
  1093.             }
  1094.             else if (is_const_uint(opd)) {
  1095.                 result = rat_const(rat_fri(UINTV(opd), int_fri(1)));
  1096.             }
  1097.             else
  1098.                 chaos("const wrong type (eval.c)");
  1099.         }
  1100.         else
  1101.             result = const_new(CONST_OM);
  1102.     }
  1103.     else if (typ1 == symbol_float) {
  1104.         if (typ2 == symbol_integer || typ2 == symbol_universal_integer) {
  1105.             Rational z;
  1106.             int *x, *y;
  1107.             const_check(opd, CONST_REAL);
  1108.             z = rat_frr((double)(REALV(opd) + 0.5));
  1109.             x = num(z);
  1110.             y = den(z);
  1111.             result = uint_const(int_quo(x, y));
  1112.         }
  1113.         else if (typ2 == symbol_float) {
  1114.             result = opd;
  1115.         }
  1116.         else if (typ2 == symbol_dfixed || typ2 == symbol_universal_real
  1117.           || typ2 == symbol_universal_fixed) {
  1118.             result = rat_const(rat_frr((double)REALV(opd)));
  1119.         }
  1120.         else
  1121.             result = const_new(CONST_OM);
  1122.     }
  1123.     else if (typ1 == symbol_universal_integer) {
  1124.         if (typ2 == symbol_integer)
  1125. /*
  1126.             result = opd;
  1127. */
  1128.             result = int_const(int_toi(UINTV(opd)));
  1129.         else if (typ2 == symbol_float) {
  1130.             /* result = [opd, 1]; */
  1131.             /*    result = real_const((float) UINTV(opd)); */
  1132.             /*result = rat_const(rat_new(UINTV(opd), int_fri(1))); */
  1133.             result = const_new (CONST_OM);
  1134.         }
  1135.         else if (typ2 == symbol_universal_integer) {
  1136.             result = opd;
  1137.         }
  1138.         else if ( typ2 == symbol_universal_real ||
  1139.             typ2 == symbol_universal_fixed ||
  1140.             typ2 == symbol_dfixed) {
  1141.             result = rat_const(rat_fri(UINTV(opd), int_fri(1)));
  1142.         }
  1143.         else
  1144.             result = const_new(CONST_OM);
  1145.     }
  1146.     else if (typ1 == symbol_universal_real || typ1 == symbol_universal_fixed
  1147.       || typ1 == symbol_dfixed) {
  1148.  
  1149.         if (typ2 == symbol_float) {
  1150.             result = real_const (rat_tor (RATV (opd), ADA_REAL_DIGITS));
  1151.             if (arith_overflow) {
  1152.                 arith_overflow = FALSE;
  1153.                 create_raise (node, symbol_constraint_error);
  1154.                 result = const_new (CONST_OM);
  1155.             }
  1156.         }
  1157.         else if (typ2 == symbol_universal_real
  1158.           || typ2 == symbol_universal_fixed || typ2 == symbol_dfixed) {
  1159.             result = opd;
  1160.         }
  1161.         else if (typ2 == symbol_integer) {
  1162.             const_check(opd, CONST_RAT);
  1163.             result = int_const(rat_toi(RATV(opd)));
  1164.         }
  1165.         else
  1166.             result = const_new(CONST_OM);
  1167.     }
  1168.     else 
  1169.         result = const_new(CONST_OM);
  1170.  
  1171.     return result;
  1172. }
  1173.  
  1174. static Const eval_qual_range(Node op1, Symbol op_type)        /*;eval_qual_range*/
  1175. {
  1176.     /* This has been separated from the main body of const_fold because
  1177.      * it is used for two differents operators: 'qual_range' proper,
  1178.      * and 'in' and 'notin'
  1179.      *
  1180.      * If the expression is not static it return the former expression expn.
  1181.      * If the expression evaluates to a ['raise', 'CONSTRAINT_ERROR'] because
  1182.      * op1 is not in the range op2, it returns the string 'contraint_error'
  1183.      * without emitting any warning; this is left to the caller
  1184.      * responsibility.
  1185.      */
  1186.     Node    lo, hi;
  1187.     Const    op1_val, lo_val, hi_val;
  1188.     int        c_error;
  1189.     Tuple    numcon;
  1190.     Rational    rop1_val;
  1191.  
  1192.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : eval_qual_range");
  1193.  
  1194.     op1_val = const_fold(op1);
  1195.     if (op1_val->const_kind == CONST_OM)
  1196.         return const_new(CONST_OM);
  1197.  
  1198.     /* May just be a type name. */
  1199.     if (is_scalar_type(op_type)) {
  1200.         numcon = SIGNATURE(op_type);
  1201.         if (numcon != (Tuple)0) {
  1202.             lo = (Node) numcon[2];
  1203.             hi = (Node) numcon[3];
  1204.         }
  1205.         else {
  1206.             lo = (Node) 0;
  1207.             hi = (Node) 0;
  1208.         }
  1209.     }
  1210.     else
  1211.         return const_new(CONST_OM);
  1212.  
  1213.     /* If the argument is universal, convert it to
  1214.      * standard representation. A qual_range indicates
  1215.      * a constrained type, i.e. non-universal.
  1216.      */
  1217.  
  1218.     if (is_universal_integer(op1_val)) {
  1219.         const_check(op1_val, CONST_UINT);
  1220.         op1_val = int_const(int_toi(UINTV(op1_val)));
  1221.         if (arith_overflow) {
  1222.             arith_overflow = 0;
  1223.             return const_new(CONST_CONSTRAINT_ERROR);
  1224.         }
  1225.     }
  1226.     else if (is_universal_real(op1_val)
  1227.       && (!is_fixed_type(root_type(op_type)))) {
  1228.         const_check(op1_val, CONST_RAT);
  1229.         op1_val = real_const(rat_tor(RATV(op1_val), ADA_REAL_DIGITS));
  1230.         if (arith_overflow) {
  1231.             arith_overflow = FALSE;
  1232.             return const_new(CONST_CONSTRAINT_ERROR);
  1233.         }
  1234.     }
  1235.     if (N_KIND(lo) != as_ivalue || N_KIND(hi) != as_ivalue) {
  1236.         return const_new(CONST_OM);
  1237.     }
  1238.     else {
  1239.         lo_val = (Const) N_VAL(lo);
  1240.         hi_val = (Const) N_VAL(hi);
  1241.     }
  1242.     /* The overflow test done here in SETL version is done above after
  1243.      * calls to arith routines in C version 
  1244.      */
  1245.  
  1246.     if (op_type == symbol_integer || op_type == symbol_float
  1247.       || op_type == symbol_dfixed || op_type == symbol_character
  1248.       || NATURE(op_type) == na_enum) {
  1249.         /*    Predefined types: value is already known to be in range.*/
  1250.         return op1_val;
  1251.     }
  1252.     else {
  1253.         /* At this point everything is known to be constant.
  1254.          * If the constraint is obeyed, return the value without
  1255.          * a range qualification. Otherwise emit a constraint
  1256.          * exception.
  1257.          */
  1258.  
  1259.         /* c_error =     ( root_type(op_type) != symbol_dfixed ?
  1260.          * (op1_val < lo_val) || (op1_val > hi_val)
  1261.          */
  1262.         if (is_fixed_type(root_type(op_type))) {
  1263.             if (op1_val->const_kind == CONST_RAT) {
  1264.                 const_check(op1_val, CONST_RAT);
  1265.                 const_check(lo_val, CONST_RAT);
  1266.                 const_check(hi_val, CONST_RAT);
  1267.                 c_error = (rat_lss(RATV(op1_val), RATV(lo_val))
  1268.                   || rat_gtr(RATV(op1_val), RATV(hi_val)));
  1269.             }
  1270.             else if (op1_val->const_kind == CONST_REAL) {
  1271.                 rop1_val = rat_frr(REALV(op1_val));
  1272.                 const_check(lo_val, CONST_RAT);
  1273.                 const_check(hi_val, CONST_RAT);
  1274.                 c_error = (rat_lss(rop1_val, RATV(lo_val))
  1275.                   || rat_gtr(rop1_val, RATV(hi_val)));
  1276.             }
  1277.         }
  1278.         else if (op1_val->const_kind == CONST_INT) {
  1279.             const_check(op1_val, CONST_INT);
  1280.             const_check(lo_val, CONST_INT);
  1281.             const_check(hi_val, CONST_INT);
  1282.             c_error = (INTV(op1_val) < INTV(lo_val))
  1283.               || (INTV(op1_val) > INTV(hi_val));
  1284.         }
  1285.         else if (op1_val->const_kind == CONST_REAL) {
  1286.             const_check(op1_val, CONST_REAL);
  1287.             const_check(lo_val, CONST_REAL);
  1288.             const_check(hi_val, CONST_REAL);
  1289.             c_error = (REALV(op1_val) < REALV(lo_val))
  1290.               || (REALV(op1_val) > REALV(hi_val));
  1291.         }
  1292.         if (c_error) {
  1293.             return const_new(CONST_CONSTRAINT_ERROR);
  1294.         }
  1295.         else {
  1296.             return op1_val;
  1297.         }
  1298.     }
  1299. }
  1300.  
  1301. static Const eval_real_type_attribute(Node node)  /*;eval_real_type_attribute*/
  1302. {
  1303.     /*
  1304.      *    Static evaluation of real types characteristics
  1305.      *    ===============================================
  1306.      */
  1307.  
  1308.     Node    attr_node, arg_node, lo, hi, precision;
  1309.     Const    result, precision_const;
  1310.     Tuple    sig;
  1311.     int        kind, attrkind, static_bounds;
  1312.     int        fl_digits;
  1313.     Rational    delta, fx_low, fx_high, xdelta, small;
  1314.     /* the following are macros in SETL, and should eventually be converted */
  1315.  
  1316. #define rat_1 rat_fri(int_fri(1), int_fri(1))
  1317. #define rat_2 rat_fri(int_fri(2), int_fri(1))
  1318.  
  1319.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : eval_real_type_attribute");
  1320.  
  1321.     attr_node = N_AST1(node);
  1322.     arg_node = N_AST2(node);
  1323.     result = const_new(CONST_OM);
  1324.     sig = SIGNATURE(N_UNQ(arg_node));
  1325.     kind = (int) sig[1];
  1326.     /*
  1327.      *    Part A : FLOATING POINT REAL
  1328.      *
  1329.      *    For a floating point real type FL, we have the following
  1330.      *    basic informations:
  1331.      *      digits  (SETL_integer)
  1332.      *      fl_high (SETL_real)
  1333.      *      fl_low  (SETL_real)
  1334.      */
  1335.  
  1336.     if (kind == CONSTRAINT_DIGITS) {
  1337.         lo = (Node) sig[2];
  1338.         hi = (Node) sig[3];
  1339.         precision = (Node) sig[4];
  1340.         precision_const = (Const) N_VAL(precision);
  1341.         const_check(precision_const, CONST_INT);
  1342.         fl_digits = INTV(precision_const);
  1343.         attrkind = (int) attribute_kind(node);
  1344.         /*
  1345.          *
  1346.          *     FL'DIGITS    --> universal_integer
  1347.          *
  1348.          *          The minimum number of significant decimal digits.
  1349.          */
  1350.         if (attrkind == ATTR_DIGITS) {
  1351.             result = uint_const(int_fri(fl_digits));
  1352.         }
  1353.         /*
  1354.          *
  1355.          *     FL'MANTISSA  --> universal_integer
  1356.          *
  1357.          *          The minimum number of binary digits required for DIGITS:
  1358.          *            ceil(fl_digits*log(10)/log(2))+1)
  1359.          *
  1360.          */
  1361.  
  1362.         else if (attrkind == ATTR_MANTISSA) {
  1363.             result = uint_const(fl_mantissa(fl_digits));
  1364.         }
  1365.         /*
  1366.          *     FL'EPSILON   --> universal_real
  1367.          *
  1368.          *          The absolute value of the difference between the nuber 1.0
  1369.          *          and the next model number above :
  1370.          *            = 2.0**(1-FL'MANTISSA)
  1371.          */
  1372.         else if (attrkind == ATTR_EPSILON) {
  1373.             result = rat_const(rat_exp(rat_2, int_sub(int_fri(1),
  1374.               fl_mantissa(fl_digits))));
  1375.         }
  1376.         /*
  1377.          *     FL'EMAX      --> universal_integer
  1378.          *
  1379.          *          The largest exponent value in binary canonical form:
  1380.          *            = 4*FL'MANTISSA
  1381.          */
  1382.         else if (attrkind == ATTR_EMAX || attrkind == ATTR_SAFE_EMAX) {
  1383.             result = uint_const(fl_emax(fl_digits));
  1384.         }
  1385.         /*
  1386.          *     FL'SMALL     --> universal_real
  1387.          *
  1388.          *          The smallest positive non-zero number :
  1389.          *            = 2.0**(- FL'EMAX -1)
  1390.          */
  1391.         else if (attrkind == ATTR_SMALL || attrkind == ATTR_SAFE_SMALL) {
  1392.             result = rat_const( rat_exp(rat_2, 
  1393.               int_umin(int_add(fl_emax(fl_digits), int_fri(1)))));
  1394.         }
  1395.         /*
  1396.          *     FL'LARGE     --> universal_integer
  1397.          *
  1398.          *           The largest positive number:
  1399.          *             = 2.0**FL'EMAX * (1.0 - 2.0**(-FL'MANTISSA))
  1400.          */
  1401.         else if (attrkind == ATTR_LARGE || attrkind == ATTR_SAFE_LARGE) {
  1402.             /* TBSL: check types, this looks wrong */
  1403.             result = rat_const(rat_mul( rat_exp(rat_2, fl_emax(fl_digits)),
  1404.               rat_sub(rat_1, rat_exp(rat_2,int_umin(fl_mantissa(fl_digits))))));
  1405.         }
  1406.         /*
  1407.          *     FL'SAFE_EMAX =  FL'BASE'EMAX
  1408.          *     FL'SAFE_SMALL =  FL'BASE'SMALL
  1409.          *     FL'SAFE_LARGE =  FL'BASE'LARGE
  1410.          *
  1411.          *      cf. FL'EMAX, FL'SMALL, FL'LARGE
  1412.          */
  1413.  
  1414.         /*
  1415.          *     FL'MACHINE_ROUNDS --> boolean
  1416.          */
  1417.         else if (attrkind == ATTR_MACHINE_ROUNDS) {
  1418.             result = test_expr(FALSE);
  1419.         }
  1420.         /*
  1421.          *     FL'MACHINE_OVERFLOWS --> boolean
  1422.          */
  1423.         else if (attrkind == ATTR_MACHINE_OVERFLOWS) {
  1424.             result = test_expr(TRUE);
  1425.         }
  1426.         /*
  1427.          *     FL'MACHINE_RADIX     --> universal_integer
  1428.          */
  1429.         else if (attrkind == ATTR_MACHINE_RADIX) {
  1430.             result = uint_const(int_fri(2));
  1431.         }
  1432.  
  1433.         /*
  1434.          *     FL'MACHINE_MANTISSA  --> universal_integer
  1435.          */
  1436.         else if (attrkind == ATTR_MACHINE_MANTISSA) {
  1437.             result = uint_const(int_fri(24));
  1438.         }
  1439.         /*
  1440.          *     FL'MACHINE_EMAX      --> universal_integer
  1441.          */
  1442.         else if (attrkind == ATTR_MACHINE_EMAX) {
  1443.             result = uint_const(int_fri(127));
  1444.         }
  1445.         /*
  1446.          *     FL'MACHINE_EMIN      --> universal_integer
  1447.          */
  1448.         /* We have to modified MACHINE_EMIN so that test c45524a de C4dep */
  1449.         /* passes */
  1450.         else if (attrkind == ATTR_MACHINE_EMIN) {
  1451.             result = uint_const(int_fri(-127));
  1452.         }
  1453.     }
  1454.     /*
  1455.      *    Part B : FIXED POINT REAL
  1456.      *
  1457.      *    For a fixed point real type FX, we have the following basic
  1458.      *    informations:
  1459.      *     delta      (universal_real)
  1460.      *     fx_low      (universal_real)
  1461.      *     fx_high  (universal_real)
  1462.      *    but the bounds may not be static...
  1463.      */
  1464.     else if (kind == CONSTRAINT_DELTA) {
  1465.         attrkind = (int) attribute_kind(node);
  1466.         if (attrkind == ATTR_SAFE_LARGE || attrkind == ATTR_SAFE_SMALL)
  1467.             sig = SIGNATURE(base_type(N_UNQ(arg_node)));
  1468.         lo = (Node) sig[2];
  1469.         hi = (Node) sig[3];
  1470.         precision = (Node) sig[4];
  1471.         static_bounds = (is_static_expr(lo) && is_static_expr(hi));
  1472.         delta = RATV((Const) N_VAL(precision));
  1473.         small = RATV((Const)N_VAL((Node)numeric_constraint_small(sig)));
  1474.         if (static_bounds) {
  1475.             eval_static(lo);
  1476.             eval_static(hi);
  1477.             const_check((Const)N_VAL(lo), CONST_RAT);
  1478.             const_check((Const)N_VAL(hi), CONST_RAT);
  1479.             fx_low = RATV((Const)N_VAL(lo));
  1480.             fx_high = RATV((Const) N_VAL(hi));
  1481.         }
  1482.         /*
  1483.          *     FX'DELTA     --> universal_real
  1484.          *
  1485.          *          The absolute value of the error bound.
  1486.          */
  1487.         if (attrkind == ATTR_DELTA) {
  1488.             result = rat_const(delta);
  1489.         }
  1490.         /*
  1491.          *     FX'SMALL     --> universal_real
  1492.          *
  1493.          *          The largest power of 2 not greater than the delta:
  1494.          *         = 2.0**floor(log(delta)/log(2.0))
  1495.          */
  1496.         else if (attrkind == ATTR_SMALL || attrkind == ATTR_SAFE_SMALL) {
  1497.             result = rat_const(small);
  1498.         }
  1499.         /*
  1500.          *     FX'MANTISSA  --> universal_integer
  1501.          *
  1502.          *         The number of binary digits required:
  1503.          *        = ceil(log(max(abs(fx_high), abs(fx_low))/FX'SMALL)/log(2.0)))
  1504.          */
  1505.  
  1506.         else if (attrkind == ATTR_MANTISSA) {
  1507.             if (static_bounds) {
  1508.                 result=uint_const(int_fri(fx_mantissa(fx_high, fx_low, small)));
  1509.             }
  1510.         }
  1511.         /*
  1512.          *     FX'LARGE     --> universal_real
  1513.          *
  1514.          *          The largest positive number :
  1515.          *         = (2.0**FX'MANTISSA - 1) * FX'SMALL
  1516.          */
  1517.         else if (attrkind == ATTR_LARGE || attrkind == ATTR_SAFE_LARGE) {
  1518.             if (static_bounds) {
  1519.                 result = rat_const(rat_mul( rat_sub(rat_exp(rat_2,
  1520.                   int_fri( fx_mantissa(fx_high, fx_low, small))), rat_1),
  1521.                   small));
  1522.             }
  1523.         }
  1524.         /*
  1525.          *     FX'FORE      --> universal_integer
  1526.          *
  1527.          *          The minimum number of characters needed for the integer
  1528.          *          part of the decimal representation (including sign).
  1529.          */
  1530.         else if (attrkind == ATTR_FORE) {
  1531.             if (static_bounds) {
  1532.                 int *ivalue_10, *rat_n, *rat_d; /* Multi-precision numbers */
  1533.                 int ivalue_n;
  1534.                 Rational fx_maximum;
  1535.  
  1536.                 ivalue_10 = int_fri(10);
  1537.                 ivalue_n = 2;
  1538.                 fx_maximum = fx_max(fx_high, fx_low);
  1539.                 rat_n = num(rat_abs(fx_maximum));
  1540.                 rat_d = den(rat_abs(fx_maximum));
  1541.                 while (int_geq(int_quo(rat_n, rat_d), ivalue_10)) {
  1542.                     rat_d = int_mul(rat_d, ivalue_10);
  1543.                     ivalue_n += 1;
  1544.                 }
  1545.                 result = uint_const(int_fri(ivalue_n));
  1546.             }
  1547.         }
  1548.         /*
  1549.          *     FX'AFT          --> universal_integer
  1550.          *
  1551.          *          The number of decimal digits needed after the decimal point
  1552.          *        = smallest n such that (10**N)*FX'DELTA >= 1.0
  1553.          */
  1554.         else if (attrkind == ATTR_AFT) {
  1555.             xdelta = delta;
  1556.             result = uint_const(int_fri(1));
  1557.             while (rat_lss(xdelta, rat_fri(int_fri(1), int_fri(10)))) {
  1558.                 xdelta = rat_mul(xdelta, rat_fri(int_fri(10), int_fri(1)));
  1559.                 UINTV(result)= int_add(UINTV(result), int_fri(1));
  1560.             }
  1561.         }
  1562.         /*
  1563.          *     FX'SAFE_SMALL =  FX'BASE'SMALL
  1564.          *     FX'SAFE_LARGE =  FX'BASE'LARGE
  1565.          *
  1566.          *     cf. FX'SMALL and FX'LARGE
  1567.          */
  1568.  
  1569.         /*
  1570.          *     FX'MACHINE_ROUNDS --> boolean
  1571.          */
  1572.         else if (attrkind == ATTR_MACHINE_ROUNDS) {
  1573.             result = test_expr(TRUE);
  1574.         }
  1575.         /*
  1576.          *     FX'MACHINE_OVERFLOWS --> boolean
  1577.          */
  1578.         else if (attrkind == ATTR_MACHINE_OVERFLOWS) {
  1579.             result = test_expr(TRUE);
  1580.         }
  1581.     }
  1582.     return result;
  1583. }
  1584.  
  1585. static Const check_overflow(Node node, Const x)                /*check_overflow*/
  1586. {
  1587.     /*
  1588.      * Check_overflow tests its argument against ADA_MAX_INTEGER or
  1589.      * ADA_MAX_REAL, returning the setl value of the argument or the
  1590.      * raise NUMERIC_ERROR instruction.  Universal integers and reals are
  1591.      * converted to setl values.
  1592.      */
  1593.  
  1594.     int    attrkind;
  1595.     Const    result;
  1596.  
  1597.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  check_overflow");
  1598.  
  1599.     return const_new(CONST_OM); /*TBSL: for initial chceckout */
  1600. #ifdef TBSL
  1601.     if (!is_numeric(N_TYPE(node))
  1602.         return;
  1603.     else if (x == symbol_overflow) {
  1604.         create_raise(node, symbol_constraint_error);
  1605.         result = om;
  1606.     }
  1607.     else
  1608.         attrkind = (int) attribute_kind(node); /*TBSL - check this  ds 14 nov */
  1609.     case(type(x)) {
  1610.             if (streq(attr, "INTEGER")) {
  1611.                 /*if (abs(x) > ADA_MAX_INTEGER) { 
  1612.              This previous test was wrong due to disymetry */
  1613.                 if ((x> ADA_MAX_INTEGER) || (x < ADA_MIN_INTEGER)) {
  1614.                     create_raise(node, symbol_constraint_error);
  1615.                         result = om;
  1616.                 }
  1617.                 else
  1618.                     result = x;
  1619.             }
  1620.             else if (streq(attr, "REAL")) {
  1621.                 if (abs(x) > ADA_MAX_REAL) {
  1622.                     create_raise(node, symbol_constraint_error);
  1623.                         result = om;
  1624.                 }
  1625.                 else
  1626.                     result = x;
  1627.             }
  1628.             else if (streq(attr, "TUPLE")) {
  1629.                 if is_universal_integer(x) {
  1630.                     if ((res = int_toi(x)) == 'OVERFLOW') {
  1631.                         create_raise(node, symbol_constraint_error);
  1632.                             result = om;
  1633.                     }
  1634.                     else
  1635.                         result = res;
  1636.                 }
  1637.                 else
  1638.                     if ((res = rat_tor(x, ada_real_digits)) == 'OVERFLOW') {
  1639.                         create_raise(node, symbol_constraint_error);
  1640.                             result = om;
  1641.                     }
  1642.                     else
  1643.                         result = res;
  1644.         else
  1645.             ;        /* Not a numeric node */
  1646.             }
  1647.             return result;
  1648. #endif
  1649.  
  1650. }
  1651.  
  1652. static int  *fl_mantissa(int fl_digits)                        /*;fl_mantissa*/
  1653. {
  1654.     /*
  1655.      *            ceil(fl_digits*log(10)/log(2))+1)
  1656.      */
  1657.     return (int_fri((int)ceil(((double)fl_digits*log(10.0))/log(2.0) + 1.0)));
  1658. }
  1659.  
  1660. static int *fl_emax(int fl_digits)                            /*;fl_emax*/
  1661. {
  1662.     return    int_mul(int_fri(4), fl_mantissa(fl_digits));
  1663. }
  1664.  
  1665. int is_universal_integer(Const x)                /*;is_universal_integer*/
  1666. {
  1667.     return is_const_uint(x);
  1668. }
  1669.  
  1670. int is_universal_real(Const x)                        /*;is_universal_real*/
  1671. {
  1672.     return  is_const_rat(x);
  1673. }
  1674.  
  1675. static void insert_and_prune(Node node, Const value)    /*;insert_and_prune*/
  1676. {
  1677.     /* When an expression tree can be constant-folded, it is reduced to a
  1678.      * formattd value for the interpreter, and its descendants are dis-
  1679.      * carded. The type has been established during type resolution.
  1680.      */
  1681.     int nk;
  1682.     Span savespan;
  1683.  
  1684.     if (cdebug2 > 3) { }
  1685.  
  1686.     nk = N_KIND(node);
  1687.  
  1688.     savespan = get_left_span(node);
  1689.     if (N_AST1_DEFINED(nk)) N_AST1(node) = (Node) 0;
  1690.     if (N_AST4_DEFINED(nk)) N_AST4(node) = (Node) 0;
  1691.     N_KIND(node) = as_ivalue;
  1692.     N_UNQ(node) = (Symbol) 0; /* as_ivalue has no n_unq */
  1693.     N_VAL(node) = (char *) value;
  1694.     N_SPAN0(node) = savespan->line;
  1695.     N_SPAN1(node) = savespan->col;
  1696. }
  1697.  
  1698. void create_raise(Node node, Symbol exception)                /*;create_raise*/
  1699. {
  1700.     /* This routine replaces the subtree at node by a -raise- operator
  1701.      * with -exception- as its operand
  1702.      */
  1703.     Node    excp_node;
  1704.     Node    span_node;
  1705.  
  1706.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  create_raise");
  1707.  
  1708.     warning(strjoin("Evaluation of expression will raise ",
  1709.       ORIG_NAME(exception)), node);
  1710.  
  1711.     excp_node = node_new(as_simple_name);
  1712.     span_node = node_new(as_simple_name);
  1713.     copy_span(node, excp_node);
  1714.     copy_span(node, span_node);
  1715.     N_UNQ(excp_node) = exception;
  1716.     N_KIND(node) = as_raise;
  1717.     N_AST1(node) = excp_node;
  1718.     N_AST2(node) = span_node;
  1719.     N_TYPE(node) = (Symbol)0;
  1720.  
  1721.     return;
  1722. }
  1723.  
  1724. static Rational fx_max (Rational fx_high, Rational fx_low)            /*;fx_max*/
  1725. {
  1726.     if (rat_geq(rat_abs(fx_high), rat_abs(fx_low)))
  1727.         return rat_abs(fx_high);
  1728.     else 
  1729.         return rat_abs(fx_low);
  1730. }
  1731.  
  1732. static Const test_expr(int e)                                /*;test_expr*/
  1733. {
  1734.     Const    res;
  1735.  
  1736.     res = const_new(CONST_INT);
  1737.     INTV(res) = e;
  1738.     return res;
  1739. }
  1740.